Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume26/veos-2.0/part13

Text File | 1993-04-25 | 74.2 KB | 2,483 lines

Newsgroups: comp.sources.unix
From: [e-mail] (Geoffery Coco)
Subject: v26i196: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part13/16
Sender: [e-mail]
Approved: [e-mail]

Submitted-By: [e-mail] (Geoffery Coco)
Posting-Number: Volume 26, Issue 196
Archive-Name: veos-2.0/part13

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 13 (of 16)."
# Contents:  kernel_private/src/nancy/nancy_fundamental.c
#   src/xlisp/xcore/doc/internals.doc
# Wrapped by [e-mail] on Sun Apr 25 23:10:45 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'kernel_private/src/nancy/nancy_fundamental.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'kernel_private/src/nancy/nancy_fundamental.c'\"
else
echo shar: Extracting \"'kernel_private/src/nancy/nancy_fundamental.c'\" \(31245 characters\)
sed "s/^X//" >'kernel_private/src/nancy/nancy_fundamental.c' <<'END_OF_FILE'
X/****************************************************************************************
X *                                            *
X * file: nancy.c                                    *
X *                                            *
X * August 21, 1990: the world(s)' interface to grouples.                       *
X *                                            *
X * by Geoffrey P. Coco at the HITLab, Seattle.                          *
X *                                            *
X ****************************************************************************************/
X
X/****************************************************************************************
X * Copyright (C) 1992  Geoffrey P. Coco, Human Interface Technology Lab, Seattle    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X *                          includes galore                    */
X
X#include "kernel.h"
X#include <string.h>
X#include <malloc.h>
X#include <varargs.h>
X
X/****************************************************************************************/
X
X
X/****************************************************************************************
X *                     forward function declarations                */
X
X
X/* nancy setup and preprocessing */
X
XTVeosErr Nancy_Init();
X
X
X/* fundamental grouple data structure utils */
X
XTVeosErr Nancy_NewGrouple();
XTVeosErr Nancy_DisposeGrouple();
XTVeosErr Nancy_CopyGrouple();
XTVeosErr Nancy_CreateElement();
XTVeosErr Nancy_DisposeElement();
XTVeosErr Nancy_CopyElement();
XTVeosErr Nancy_NewElementsInGrouple();
XTVeosErr Nancy_DeleteElementsInGrouple();
X
X
X/* related public nancy utils */
X
XTVeosErr Nancy_GroupleToStream();
XTVeosErr Nancy_ElementToStream();
XTVeosErr Nancy_GroupleToStreamWithLevel();
XTVeosErr Nancy_ElementToStreamWithLevel();
X
XTVeosErr Nancy_EmptyGrouple();
XTVeosErr Nancy_InsertEltList();
XTVeosErr Nancy_CopyEltList();
XTVeosErr Nancy_ConcatGrouple();
X
XTVeosErr Nancy_GetFileSize();
XTVeosErr Nancy_FileToGrouple();
XTVeosErr Nancy_TrapErr();
X
X
X/* private nancy utils */
X
XTVeosErr Nancy_ResizeEltList();
XTVeosErr Nancy_SetupTypeSizes();
X
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X *                setup and preprocessing                    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_Init                                    */
X
XTVeosErr Nancy_Init()
X{
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_MEM_ERR;
X    LINE_COUNT = 0;
X    NANCY_MINTIME = 0;
X    NANCY_TIME = 1;
X
X    /** setup runtime hash table for element sizes **/
X
X    iSuccess = Nancy_SetupFastMem();
X    if (iSuccess == VEOS_SUCCESS) {
X
X    /** StreamToElement assumes global buffer **/
X
X    if (NEWPTR(NANCY_BUF, char *, VEOS_GROUPLE_BUF_SIZE)) {
X
X        NIL_ELT.iType = GR_unspecified;
X        NIL_ELT.u.pU = nil;
X        NIL_ELT.tLastMod = 0x7FFFFFFF;
X        NIL_ELT.iFlags = 0;
X
X        iSuccess = Nancy_NewGrouple(&GR_INSPACE);
X        if (iSuccess == VEOS_SUCCESS) {
X
X        iSuccess = Nancy_NewGrouple(&WORK_SPACE);
X        }
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_Init */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X *             fundamental nancy data structure utils                *
X ****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_NewGrouple                                    */
X
XTVeosErr Nancy_NewGrouple(hDestGrouple)
X    THGrouple        hDestGrouple;
X{
X    TVeosErr        iSuccess;
X    TPGrouple        pNewGrouple;
X
X
X    iSuccess = VEOS_FAILURE;                       /* pessimism */
X
X
X    if (hDestGrouple) {                    /* sanity check */
X
X    iSuccess = VEOS_MEM_ERR;            /* more pessimism */
X
X    *hDestGrouple = (TPGrouple) nil;
X
X
X
X    /** allocate the grouple structure itself **/
X
X    iSuccess = Shell_NewBlock(TYPE_SIZES[GR_grouple], &pNewGrouple,
X                  "grouple");
X
X    if (iSuccess == VEOS_SUCCESS) {
X        pNewGrouple->pEltList = nil;
X        pNewGrouple->iElts = 0;
X        pNewGrouple->iFlags = 0;
X
X        *hDestGrouple = pNewGrouple;
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_NewGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_DisposeGrouple                                    */
X
XTVeosErr Nancy_DisposeGrouple(pDeadGrouple)
X    TPGrouple        pDeadGrouple;
X{
X    TVeosErr        iSuccess;
X    int            iEltIndex;
X    TPElt        pEltList;
X
X    iSuccess = VEOS_SUCCESS;            /* what could go wrong? */
X
X    if (pDeadGrouple) {                /* sanity check */
X
X
X    /** clear all elements from grouple **/
X
X    Nancy_DeleteElementsInGrouple(pDeadGrouple, 0, pDeadGrouple->iElts);
X
X
X    /** deallocate element list itself **/
X
X    Nancy_ResizeEltList(pDeadGrouple, 0);
X
X
X    /** deallocate the grouple structure itself **/
X
X    Shell_ReturnBlock(pDeadGrouple, TYPE_SIZES[GR_grouple], "grouple");
X    }
X
X
X    return(iSuccess);
X
X    } /* Nancy_DisposeGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_CopyGrouple                                    */
X
XTVeosErr Nancy_CopyGrouple(pSrcGrouple, pDestGrouple)
X    TPGrouple        pSrcGrouple;
X    TPGrouple        pDestGrouple;
X{
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_FAILURE;                          /* pessimism */
X
X    if (pSrcGrouple && pDestGrouple) {                /* sanity check */
X
X    /** allocate element list enough for all copied elements **/
X
X    iSuccess = Nancy_ResizeEltList(pDestGrouple, pSrcGrouple->iElts);
X    if (iSuccess == VEOS_SUCCESS) {
X
X
X        iSuccess = Nancy_CopyEltList(pSrcGrouple->pEltList,
X                     pDestGrouple->pEltList,
X                     pSrcGrouple->iElts);
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_CopyGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_CreateElement                                    */
X
XTVeosErr Nancy_CreateElement(pDestElt, iType, iSize)
X    TPElt        pDestElt;
X    int            iType, iSize;
X{
X    TVeosErr        iSuccess;
X    str15        sTypeName;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pDestElt) {        /* sane? */
X
X    pDestElt->iType = iType;
X
X    iSuccess = VEOS_MEM_ERR;
X
X    switch (iType) {
X
X    case GR_grouple:
X        iSuccess = Nancy_NewGrouple(&pDestElt->u.pGr);
X        break;
X
X    case GR_vector:
X        iSuccess = Nancy_NewGrouple(&pDestElt->u.pGr);
X        pDestElt->iType = GR_vector;
X        break;
X
X    case GR_string:
X    case GR_prim:
X        if (iSize > 0) {
X        if (NEWPTR(pDestElt->u.pS, char *, iSize))
X            iSuccess = VEOS_SUCCESS;
X        }
X        else {
X        pDestElt->u.pS = nil;
X        iSuccess = VEOS_SUCCESS;
X        }
X        break;
X
X    case GR_float:
X    case GR_int:
X    case GR_these:
X    case GR_theseall:
X    case GR_some:
X    case GR_any:
X    case GR_here:
X        /* nothing to allocate */
X        iSuccess = VEOS_SUCCESS;
X        break;
X
X    case GR_unspecified:
X    default:
X        pDestElt->u.pU = nil;
X        iSuccess = VEOS_SUCCESS;
X        break;
X
X        } /* switch */
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_CreateElement */
X/****************************************************************************************/
X
X
X
X
X
X/****************************************************************************************
X * Nancy_DisposeElement                                    */
X
XTVeosErr Nancy_DisposeElement(pDestElt)
X    TPElt        pDestElt;
X{
X    TVeosErr        iSuccess;
X    str15        sTypeName;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pDestElt) {
X
X    /** recurs to sublist if necessary **/
X    switch (pDestElt->iType) {
X
X    case GR_grouple:
X    case GR_vector:
X        Nancy_DisposeGrouple(pDestElt->u.pGr);
X        break;
X
X    case GR_string:
X        DUMP(pDestElt->u.pS);
X        break;
X
X    case GR_float:
X    case GR_int:
X    case GR_these:
X    case GR_theseall:
X    case GR_some:
X    case GR_any:
X    case GR_here:
X    case GR_unspecified:
X    default:
X        /* nothing allocated */
X        break;
X
X        } /* switch */
X
X    *pDestElt = NIL_ELT;
X
X    iSuccess = VEOS_SUCCESS;
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_DisposeElement */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_CopyElement                                    */
X
XTVeosErr Nancy_CopyElement(pSrcElt, pDestElt)
X    TPElt        pSrcElt, pDestElt;
X{
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pSrcElt && pDestElt && pSrcElt->iType == pDestElt->iType) {    /* sane? */
X
X    iSuccess = VEOS_SUCCESS;
X
X    switch (pSrcElt->iType) {
X
X    case GR_grouple:
X    case GR_vector:
X        iSuccess = Nancy_CopyGrouple(pSrcElt->u.pGr,
X                     pDestElt->u.pGr);
X        break;
X
X    case GR_float:
X    case GR_int:
X    case GR_these:
X    case GR_some:
X        pDestElt->u.iVal = pSrcElt->u.iVal;
X        break;
X
X    case GR_theseall:
X    case GR_any:
X    case GR_here:
X        /** no data to copy **/
X        break;
X
X    case GR_string:
X    case GR_prim:
X        if (pDestElt->u.pS)
X        strcpy(pDestElt->u.pS, pSrcElt->u.pS);
X        else
X        pDestElt->u.pS = strdup(pSrcElt->u.pS);
X        break;
X
X    case GR_unspecified:
X        break;
X
X        } /* switch */
X
X    pDestElt->tLastMod = pSrcElt->tLastMod;
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_CopyElement */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_NewElementsInGrouple                                */
X
XTVeosErr Nancy_NewElementsInGrouple(pDestGrouple, iInsertElt, iElts, iType, iSize)
X    TPGrouple        pDestGrouple;
X    int            iInsertElt, iElts, iType, iSize;
X{
X    TVeosErr        iSuccess;
X    TPElt        pEltList;
X    int            iIndex, iOldElts, iLimit;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pDestGrouple) {
X
X    iOldElts = pDestGrouple->iElts;        /* ResizeEltList() clobbers this field */
X
X    iSuccess = Nancy_ResizeEltList(pDestGrouple,
X                       iOldElts > iInsertElt ?
X                       (iOldElts + iElts) : (iInsertElt + iElts));
X    if (iSuccess == VEOS_SUCCESS) {
X
X
X
X        /** use stack var for speed **/
X
X        pEltList = pDestGrouple->pEltList;
X
X
X
X        /** all elements which occur after insertion point are shifted down **/
X
X        iIndex = iOldElts + iElts - 1;
X        iLimit = iInsertElt + iElts;
X
X        while (iIndex >= iLimit) {
X
X        pEltList[iIndex] = pEltList[iIndex - iElts];
X
X        iIndex --;
X        }
X
X
X        /** initialize new elements that may have been created by list growth **/
X
X        iIndex = iOldElts;
X        iLimit = iInsertElt + iElts;
X
X        while (iIndex < iLimit) {
X
X        pEltList[iIndex] = NIL_ELT;
X
X        iIndex ++;
X        }
X
X
X        /** attempt to create actual element data block, if requested **/
X
X        iIndex = iInsertElt;
X        iLimit = iInsertElt + iElts;
X        while (iIndex < iLimit && iSuccess == VEOS_SUCCESS) {
X
X        iSuccess = Nancy_CreateElement(&pEltList[iIndex], iType, iSize);
X
X        iIndex ++;
X        }
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_NewElementsInGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_DeleteElementsInGrouple                            */
X
XTVeosErr Nancy_DeleteElementsInGrouple(pGrouple, iStartElt, iElts)
X    TPGrouple        pGrouple;
X    int            iStartElt, iElts;
X{
X    TVeosErr        iSuccess;
X    int            iIndex, iEndElt, iNewElts;
X    TPElt        pEltList;
X
X    iSuccess = VEOS_SUCCESS;
X    iEndElt = iStartElt + iElts;
X
X    if (pGrouple &&
X    iElts > 0) {
X
X    if (pGrouple->iElts >= iEndElt) {        /* sane? */
X
X
X        /** deallocate specific element data **/
X
X        iIndex = iStartElt;
X        while (iIndex < iEndElt) {
X
X        Nancy_DisposeElement(&pGrouple->pEltList[iIndex]);
X
X        iIndex ++;
X        }
X
X
X        iSuccess = Nancy_DownShift(pGrouple, iStartElt, iElts);
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_DeleteElementsInGrouple */
X/****************************************************************************************/
X
X
X/****************************************************************************************
X                     Data Conversion
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_ElementToStream                                */
X
XTVeosErr Nancy_ElementToStream(pElt, pStream)
X    TPElt        pElt;
X    FILE        *pStream;
X{
X    TVeosErr        iSuccess;
X    FILE        *pSave;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pElt && pStream) {                /* sane? */
X
X    pSave = GR_STREAM;
X    GR_STREAM = pStream;
X
X    iSuccess = Nancy_ElementToStreamAux(pElt, 0);
X
X    GR_STREAM = pSave;
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_ElementToStream */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_GroupleToStream                                */
X
XTVeosErr Nancy_GroupleToStream(pGrouple, pStream)
X    TPGrouple        pGrouple;
X    FILE        *pStream;
X{
X    TElt        elt;
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pGrouple && pStream) {                /* sane? */
X
X    elt = NIL_ELT;
X    elt.iType = GR_grouple;
X    elt.u.pGr = pGrouple;
X
X    iSuccess = Nancy_ElementToStream(&elt, pStream);
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_GroupleToStream */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_ElementToStreamWithLevel                            */
X
XTVeosErr Nancy_ElementToStreamWithLevel(pElt, pStream, iLevel)
X    TPElt        pElt;
X    FILE        *pStream;
X    int            iLevel;
X{
X    TVeosErr        iSuccess;
X    FILE        *pSave;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pElt && pStream) {                /* sane? */
X
X    pSave = GR_STREAM;
X    GR_STREAM = pStream;
X
X    iSuccess = Nancy_ElementToStreamAux(pElt, iLevel);
X
X    GR_STREAM = pSave;
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_ElementToStreamWithLevel */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_GroupleToStreamWithLevel                            */
X
XTVeosErr Nancy_GroupleToStreamWithLevel(pGrouple, pStream, iLevel)
X    TPGrouple        pGrouple;
X    FILE        *pStream;
X    int            iLevel;
X{
X    TElt        elt;
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pGrouple && pStream) {                /* sane? */
X
X    elt = NIL_ELT;
X    elt.iType = GR_grouple;
X    elt.u.pGr = pGrouple;
X
X    iSuccess = Nancy_ElementToStreamWithLevel(&elt, pStream, iLevel);
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_GroupleToStreamWithLevel */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X                   Grouple -> Network Message
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_EltToMessage                                    */
X
XTVeosErr Nancy_EltToMessage(pElt, pBuffer, pLen)
X    TPElt        pElt;
X    char        *pBuffer;
X    int            *pLen;
X{
X    int            iLen, iType;
X
X    if (pElt) {                /* sane? */
X
X    iType = pElt->iType;
X
X    /** first part of message element is element type **/
X    /** assume pBuffer is aligned **/
X
X    *(int *) pBuffer = htonl(iType);
X
X    pBuffer += 4;
X    *pLen += 4;
X
X    switch (iType) {
X
X    case GR_grouple:
X    case GR_vector:
X        iLen = 0;
X        Nancy_GroupleToMessage(pElt->u.pGr, pBuffer, &iLen);
X        break;
X
X    case GR_int:
X    case GR_float:
X        *(long *) pBuffer = htonl(pElt->u.iVal);
X        iLen = 4;
X        break;
X
X    case GR_string:
X    case GR_prim:
X        strcpy(pBuffer, pElt->u.pS);
X        iLen = MEMSIZE(strlen(pElt->u.pS) + 1);
X        break;
X
X    case GR_unspecified:
X    default:
X        iLen = 0;
X        break;
X
X        } /* switch */
X
X    *pLen += iLen;
X    }
X
X    return(VEOS_SUCCESS);
X
X    } /* Nancy_EltToMessage */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X * Nancy_GroupleToMessage                                */
X
XTVeosErr Nancy_GroupleToMessage(pGrouple, pBuffer, pLen)
X    TPGrouple        pGrouple;
X    char        *pBuffer;
X    int            *pLen;
X{
X    int            iEltIndex, iElts, iLen;
X    TPElt        pEltList;
X
X    if (pGrouple) {                /* sane? */
X
X
X    /** use stack vars for speed **/
X
X    iElts = pGrouple->iElts;
X    pEltList = pGrouple->pEltList;
X
X
X
X    /** first code of protocol is number of elements **/
X
X    *(int *) pBuffer = htonl(iElts);    /** assume pBuffer is aligned **/
X
X    pBuffer += 4;
X    *pLen += 4;
X
X
X    for (iEltIndex = 0; iEltIndex < iElts; iEltIndex ++) {
X
X        iLen = 0;
X
X        /** invoke recursive translation **/
X
X        Nancy_EltToMessage(&pEltList[iEltIndex], pBuffer, &iLen);
X
X        pBuffer += iLen;
X        *pLen += iLen;
X        }
X    }
X
X    return(VEOS_SUCCESS);
X
X    } /* Nancy_GroupleToMessage */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X *                related public utils                    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_EmptyGrouple                                    */
X
XTVeosErr Nancy_EmptyGrouple(pGrouple)
X    TPGrouple        pGrouple;
X{
X    TVeosErr        iSuccess;
X
X    iSuccess = VEOS_FAILURE;
X
X    if (pGrouple && pGrouple->iElts > 0) {
X
X    iSuccess = Nancy_DeleteElementsInGrouple(pGrouple, 0, pGrouple->iElts);
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_EmptyGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_InsertEltList(pSrcList, iSrcElts, pDestGrouple, iStartElt)
X    TPElt        pSrcList;
X    int            iSrcElts, iStartElt;
X    TPGrouple        pDestGrouple;
X{
X    TVeosErr        iSuccess;
X    int            iSrcIndex;
X    TPElt        pDestList;
X
X
X    iSuccess = VEOS_SUCCESS;
X
X    if (pSrcList && pDestGrouple) {        /* sane? */
X
X    iSuccess = Nancy_NewElementsInGrouple(pDestGrouple,
X                          iStartElt,
X                          iSrcElts,
X                          GR_unspecified, 0);
X    if (iSuccess == VEOS_SUCCESS) {
X
X
X        /** transfer each element from chosen starting locations **/
X
X        pDestList = &pDestGrouple->pEltList[iStartElt];
X        iSrcIndex = 0;
X        while (iSrcIndex < iSrcElts) {
X
X        pDestList[iSrcIndex] = pSrcList[iSrcIndex];
X
X
X        /** set default vals for src elements **/
X        /** in case the caller disposes the src elt list after the call **/
X
X        pSrcList[iSrcIndex++] = NIL_ELT;
X        }
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_InsertEltList */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_CopyEltList(pSrcList, pDestList, iElts)
X    TPElt        pSrcList, pDestList;
X    int            iElts;
X{
X    int            iEltIndex;
X    TVeosErr        iSuccess = VEOS_SUCCESS;
X
X
X    if (pSrcList && pDestList) {        /* sane? */
X
X    /** copy the grouple element list, one elt at a time **/
X
X    iSuccess = VEOS_SUCCESS;
X    iEltIndex = 0;
X    while (iEltIndex < iElts && iSuccess == VEOS_SUCCESS) {
X
X        pDestList[iEltIndex] = pSrcList[iEltIndex];
X
X        if (pSrcList[iEltIndex].iType != GR_unspecified) {
X
X        iSuccess = Nancy_CreateElement(&pDestList[iEltIndex],
X                           pSrcList[iEltIndex].iType, 0);
X        if (iSuccess == VEOS_SUCCESS)
X
X            iSuccess = Nancy_CopyElement(&pSrcList[iEltIndex],
X                         &pDestList[iEltIndex]);
X        }
X
X        iEltIndex ++;
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_CopyEltList */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_ConcatGrouple                                    */
X
XTVeosErr Nancy_ConcatGrouple(pSrcGrouple, pDestGrouple)
X    TPGrouple        pSrcGrouple;
X    TPGrouple        pDestGrouple;
X{
X    TVeosErr        iSuccess;
X    int            iOldElts;
X
X    iSuccess = VEOS_FAILURE;                          /* pessimism */
X
X    if (pSrcGrouple && pDestGrouple) {                /* sanity check */
X
X
X    /** allocate element list enough for all copied elements **/
X
X    iOldElts = pDestGrouple->iElts;
X    iSuccess = Nancy_ResizeEltList(pDestGrouple,
X                       iOldElts + pSrcGrouple->iElts);
X    if (iSuccess == VEOS_SUCCESS) {
X
X
X        iSuccess = Nancy_CopyEltList(pSrcGrouple->pEltList,
X                     &pDestGrouple->pEltList[iOldElts],
X                     pSrcGrouple->iElts);
X        }
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_ConcatGrouple */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_EltIdentical(pLeftElt, pRightElt)
X    TPElt        pRightElt, pLeftElt;
X{
X    TVeosErr        iSuccess;
X    int            iType;
X    boolean        bSame;
X    char        *pGenericRight, *pGenericLeft, *pMax;
X
X
X    iSuccess = VEOS_FAILURE;
X    bSame = FALSE;
X
X    if (pLeftElt == pRightElt)
X    bSame = TRUE;
X
X    else if (pLeftElt &&
X         pRightElt &&
X         pLeftElt->iType == pRightElt->iType) {
X
X    iType = pLeftElt->iType;
X    switch (iType) {
X
X    case GR_float:
X        if (pLeftElt->u.fVal == pRightElt->u.fVal)
X        bSame = TRUE;
X        break;
X
X    case GR_int:
X        if (pLeftElt->u.iVal == pRightElt->u.iVal)
X        bSame = TRUE;
X        break;
X
X    case GR_string:
X    case GR_prim:
X        if (strcmp(pLeftElt->u.pS, pRightElt->u.pS) == 0)
X        bSame = TRUE;
X        break;
X
X    case GR_unspecified:
X    default:
X        bSame = TRUE;
X        break;
X
X        } /* switch */
X    }
X
X    if (bSame)
X    iSuccess = VEOS_SUCCESS;
X
X    return(iSuccess);
X
X    } /* Nancy_EltIdentical */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************
X * Nancy_TrapErr                                    */
X
XTVeosErr Nancy_TrapErr(iErr)
X    TVeosErr        iErr;
X{
X    switch(iErr) {
X
X    case NANCY_EndOfGrouple:
X    fprintf(stderr, "nancy %s: end of grouple reached\n", WHOAMI);
X    break;
X
X    case NANCY_MisplacedLeftBracket:
X    fprintf(stderr, "nancy %s: misplaced '[', near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case NANCY_MisplacedRightBracket:
X    fprintf(stderr, "nancy %s: misplaced ']', near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case NANCY_MissingRightBracket:
X    fprintf(stderr, "nancy %s: missing ']', near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case NANCY_BadType:
X    fprintf(stderr, "nancy %s: bad element type, near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case NANCY_NoTypeMatch:
X    fprintf(stderr, "nancy %s: unknown data type, near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case VEOS_EOF:
X    fprintf(stderr, "nancy %s: end of stream reached permaturely, near line: %d\n", WHOAMI, LINE_COUNT);
X    break;
X
X    case VEOS_MEM_ERR:
X    fprintf(stderr, "nancy %s: memory error\n", WHOAMI);
X    break;
X
X    case VEOS_FAILURE:
X    fprintf(stderr, "nancy %s: bad parameters\n", WHOAMI);
X    break;
X
X    case VEOS_SUCCESS:
X    fprintf(stderr, "nancy %s: success\n", WHOAMI);
X    break;
X
X    case NANCY_NoMatch:
X    fprintf(stderr, "nancy %s: no matches were found\n", WHOAMI);
X    break;
X
X    case NANCY_NotSupported:
X    fprintf(stderr, "nancy %s: that operation not currently supported\n", WHOAMI);
X    break;
X
X    case NANCY_SrcTooShort:
X    fprintf(stderr, "nancy %s: no match - source grouple shorter than pattern\n", WHOAMI);
X    break;
X
X    case NANCY_PatTooShort:
X    fprintf(stderr, "nancy %s: no match - pattern shorter than source grouple\n", WHOAMI);
X    break;
X
X    default:
X    fprintf(stderr, "nancy %s: unknown error: %d\n", WHOAMI, iErr);
X    break;
X
X    } /* switch */
X
X    } /* Nancy_TrapErr */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************
X *                       private routines                    *
X ****************************************************************************************/
X
X
X/****************************************************************************************
X * Nancy_ResizeEltList                                    */
X
XTVeosErr Nancy_ResizeEltList(pDestGrouple, iNewElts)
X    TPGrouple        pDestGrouple;
X    int            iNewElts;
X{
X    TVeosErr        iSuccess;
X    TPElt        pEltList;
X    int            iIsLen, iShouldLen;
X
X    iSuccess = VEOS_SUCCESS;
X
X    if (pDestGrouple) {                /* sane? */
X
X
X    /** if element ptr array is too long or too short, alter size **/
X
X    iShouldLen = ELTS_ALLOCATED(iNewElts);
X    iIsLen = ELTS_ALLOCATED(pDestGrouple->iElts);
X
X    if (iShouldLen != iIsLen) {
X
X        iSuccess = VEOS_MEM_ERR;
X        pEltList = nil;
X
X
X        /**---------------------------------------------------**/
X        /** use fast in-house memory scheme for element lists **/
X        /**---------------------------------------------------**/
X
X        if (iShouldLen <= 0) {
X
X        /** want to dispose all elt list memory **/
X
X        if (pDestGrouple->pEltList)
X            Shell_ReturnBlock(pDestGrouple->pEltList,
X                      iIsLen * sizeof(TElt), "elt list");
X        }
X
X        else if (pDestGrouple->pEltList) {
X
X
X        /** want to resize elt list array **/
X
X        iSuccess = Shell_NewBlock(iShouldLen * sizeof(TElt),
X                      &pEltList, "bigger elt list");
X        if (iSuccess == VEOS_SUCCESS) {
X
X            bcopy(pDestGrouple->pEltList,
X              pEltList,
X              (iIsLen < iShouldLen ? iIsLen : iShouldLen) * sizeof(TElt));
X
X            Shell_ReturnBlock(pDestGrouple->pEltList,
X                      iIsLen * sizeof(TElt), "smaller elt list");
X            }
X        }
X
X
X        else {
X        /** want to create elt list for first time **/
X
X        iSuccess = Shell_NewBlock(iShouldLen * sizeof(TElt),
X                      &pEltList, "elt list");
X        }
X
X        /** attach new element array (contains old contents) **/
X
X        if (iSuccess = VEOS_SUCCESS)
X        pDestGrouple->pEltList = pEltList;
X        }
X
X    pDestGrouple->iElts = iNewElts;
X    }
X
X    return(iSuccess);
X
X    } /* Nancy_ResizeEltList */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_DownShift(pGrouple, iStartElt, iElts)
X    TPGrouple        pGrouple;
X    int            iStartElt, iElts;
X{
X    TVeosErr        iSuccess;
X    TPElt        pEltList;
X    int            iNewElts, iIndex;
X
X
X    /** use stack vars for speed **/
X
X    pEltList = pGrouple->pEltList;
X    iNewElts = pGrouple->iElts - iElts;
X
X
X
X    iIndex = iStartElt;
X    while (iIndex < iNewElts) {
X
X    pEltList[iIndex] = pEltList[iIndex + iElts];
X
X    iIndex ++;
X    }
X
X    iSuccess = Nancy_ResizeEltList(pGrouple, iNewElts);
X
X    return(iSuccess);
X
X    } /* Nancy_DownShift */
X/****************************************************************************************/
X
X
X/****************************************************************************************/
XTVeosErr Nancy_ElementToStreamAux(pElt, iLevel)
X    TPElt        pElt;
X    int            iLevel;
X{
X    TPElt        pEltList;
X    int            iElts, iEltIndex;
X    str63        sHostName;
X
X    if (pElt) {                /* sane? */
X
X    Nancy_StreamTabs(iLevel, GR_STREAM);
X
X    if (TESTFLAG(NANCY_EltMarkMask, pElt->iFlags))
X        fprintf(stderr, "> ");
X
X    PRINT_TIME(pElt->tLastMod, stderr);
X
X
X    switch (pElt->iType) {
X
X    case GR_vector:
X        fprintf(GR_STREAM, "#");
X
X    case GR_grouple:
X        fprintf(GR_STREAM, "[\n");
X
X        pEltList = pElt->u.pGr->pEltList;
X        iElts = pElt->u.pGr->iElts;
X
X        for (iEltIndex = 0; iEltIndex < iElts; iEltIndex ++) {
X
X        /** recurs */
X        Nancy_ElementToStreamAux(&pEltList[iEltIndex], iLevel + 1);
X        }
X
X        Nancy_StreamTabs(iLevel, GR_STREAM);
X        fprintf(GR_STREAM, "]\n");
X        break;
X
X    case GR_here:
X        fprintf(GR_STREAM, "^\n");
X        break;
X
X    case GR_some:
X        fprintf(GR_STREAM, "*%d\n", pElt->u.iVal);
X        break;
X
X    case GR_any:
X        fprintf(GR_STREAM, "**\n");
X        break;
X
X    case GR_these:
X        fprintf(GR_STREAM, "@%d\n", pElt->u.iVal);
X        break;
X
X    case GR_theseall:
X        fprintf(GR_STREAM, "@@\n");
X        break;
X
X    case GR_float:
X        fprintf(GR_STREAM, "%.2f\n", pElt->u.fVal);
X        break;
X
X    case GR_int:
X        fprintf(GR_STREAM, "%d\n", pElt->u.iVal);
X        break;
X
X    case GR_string:
X        fprintf(GR_STREAM, "\"%s\"\n", pElt->u.pS);
X        break;
X
X    case GR_prim:
X        fprintf(GR_STREAM, "'prim' %s\n", pElt->u.pS);
X        break;
X
X    case GR_unspecified:
X        fprintf(GR_STREAM, "()\n");
X        break;
X
X    default:
X        break;
X
X        } /* switch */
X    }
X
X    return(VEOS_SUCCESS);
X
X    } /* Nancy_ElementToStreamAux */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_TypeToString(iType, sName)
X    int        iType;
X    char    *sName;
X{
X    if (sName) {
X
X    switch (iType) {
X
X    case GR_grouple:
X        strcpy(sName, "grouple");
X        break;
X    case GR_vector:
X        strcpy(sName, "vector");
X        break;
X    case GR_float:
X        strcpy(sName, "float");
X        break;
X    case GR_int:
X        strcpy(sName, "int");
X        break;
X    case GR_string:
X        strcpy(sName, "string");
X        break;
X    case GR_prim:
X        strcpy(sName, "prim");
X        break;
X    case GR_unspecified:
X        strcpy(sName, "unspecified");
X        break;
X    case GR_these:
X        strcpy(sName, "these");
X        break;
X    case GR_theseall:
X        strcpy(sName, "theseall");
X        break;
X    case GR_some:
X        strcpy(sName, "some");
X        break;
X    case GR_any:
X        strcpy(sName, "any");
X        break;
X    case GR_here:
X        strcpy(sName, "here");
X        break;
X    case GR_mark:
X        strcpy(sName, "mark");
X        break;
X    case GR_touch:
X        strcpy(sName, "touch");
X        break;
X    default:
X        break;
X
X        } /* switch */
X    }
X
X    return(VEOS_SUCCESS);
X
X    } /* Nancy_TypeToString */
X/****************************************************************************************/
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_StreamTabs(iTabs, pStream)
X    int        iTabs;
X    FILE    *pStream;
X{
X    while (iTabs-- > 0)
X    fprintf(pStream, "    ");
X
X    return(VEOS_SUCCESS);
X
X    } /* Nancy_StreamTabs */
X/****************************************************************************************/
X
X
X
X
X/****************************************************************************************/
XTVeosErr Nancy_SetupFastMem()
X{
X    TVeosErr        iSuccess;
X    int            i;
X
X    iSuccess = VEOS_SUCCESS;
X
X    TYPE_SIZES[GR_grouple] = TYPE_SIZES[GR_vector] = sizeof(TGrouple);
X
X    TYPE_SIZES[GR_prim] = TYPE_SIZES[GR_string] = 0;
X
X    TYPE_SIZES[GR_float] = 0;
X    TYPE_SIZES[GR_int] = 0;
X    TYPE_SIZES[GR_these] = 0;
X    TYPE_SIZES[GR_theseall] = 0;
X    TYPE_SIZES[GR_some] = 0;
X    TYPE_SIZES[GR_any] = 0;
X    TYPE_SIZES[GR_here] = 0;
X
X
X    /* the elt list for the empty grouple is nil */
X    ALLOC_ELTS[0] = 0;
X
X    /* optimize for pair-type grouples coming from lisp */
X    ALLOC_ELTS[1] = 2;
X    ALLOC_ELTS[2] = 2;
X
X    for (i = 3; i < NANCY_AllocHashMax; i++)
X    ALLOC_ELTS[i] = ELTS_TO_ALLOCATE(i);
X
X    return(iSuccess);
X
X    } /* Nancy_SetupFastMem */
X/****************************************************************************************/
X
X
X
X
X
END_OF_FILE
if test 31245 -ne `wc -c <'kernel_private/src/nancy/nancy_fundamental.c'`; then
    echo shar: \"'kernel_private/src/nancy/nancy_fundamental.c'\" unpacked with wrong size!
fi
# end of 'kernel_private/src/nancy/nancy_fundamental.c'
fi
if test -f 'src/xlisp/xcore/doc/internals.doc' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/doc/internals.doc'\"
else
echo shar: Extracting \"'src/xlisp/xcore/doc/internals.doc'\" \(39828 characters\)
sed "s/^X//" >'src/xlisp/xcore/doc/internals.doc' <<'END_OF_FILE'
XBUGGO:  Add a generic class to sample diagram.
X
X------stuff to merge in to next release-----
XDate: Fri, 16 Nov 90 15:23:47 -0500
XFrom: "Ken Whedbee" <[e-mail]>
XTo: [e-mail]
XSubject: xlisp internals
X
X
XJeff -
X
XGreat job on the xlisp internals doc.  Xlisp has been needing this for
Xa long time ...
X
XSome extras that might be nice to have in your internals doc
Xare:
X
X1.  Give sort of a high level description of whats in each
X    xl*.c file.  Some distributions of the source have
X    this at the top of the file .. some dont.
X
X2.  How about outlining the basic flow of control in xlisp ?
X
X3.  For people adding funtions, to pick up a copy of
X    Steele's Common Lisp the Language
X
X
X>From stuff i ve read it sounds like David Betze is not going
Xto do any more work on xlisp.  He's been working on xscheme
Xlately, and considers it a better language (where common
Xlisp is the extended union of all the dialects of lisp, scheme
Xis the intersection of all the dialects :)  )
X
XIf new versions of xlisp are to become available, people
Xhacking on it will be the ones turning them out.  What would
Xyou think of getting people from comp.lang.lisp.x to
Xagree on a new version ?  To my version of xlisp i ve added
Xsomething like 80 new functions .. but i ve been pretty
Xmuch sitting on it and not releasing it.
X
X-------------------------------------------
XFrom: [e-mail] (Tom Almy)
XNewsgroups: comp.lang.lisp.x
XSubject: Re: xlisp 2.1/winterp internals (26K long)
XDate: 16 Nov 90 21:13:29 GMT
XReply-To: [e-mail] (Tom Almy)
XDistribution: comp
XOrganization: Tektronix, Inc., Beaverton,  OR.
X
X>I've just finished reading the xlisp 2.1 source code for the first
X>time.  The tutorial and reference material included with the winterp
X>distribution are well done, but I would have liked an overview of the
X>interpreter internals.  Here's a first cut at such a document.
X>Comments welcome...
X
XI have spend many hours going over the listings, fixing bugs, and making
Xextensions. I wish I had this when I started. But I do have a few comments.
X
X
X>xlenv and xlfenf are conceptually a single environment, although they
X>are implemented separately. [...]
X
X>The xlfenv environment is maintained strictly parallel to xlenv, but
X>is used to find function values instead of variable values.  The
X>separation may be partly for lookup speed and partly for historical
X>reasons.
X
XThey have to be maintained separately because let lexically binds values and
Xflet, labels, and macrolet lexically bind only functions.
XFor instance consider:
X(defun x () x)
X(setq x 10)
X(let ((x 3)) (print x) (print (x)))
X
Xwill print 3 and 10.
X
Xwhile
X
X(flet ((x () (+ 1 x))) (print x) (print (x)))
X
Xwill print 10 and 11.
X
Xand
X
X(let ((x 3)) (flet ((x () (+ 1 x))) (print x) (print (x))))
X
Xwill print 3 and 4.
X
XYou couldn't do this with a combined binding list.
X
X
X>The xldenv environment tracks the old values of global variables which
X>we have changed but intend to restore later to their original values,
X>particularly when we bind and unbind s_evalhook and s_applyhook
X>(*EVALHOOK* and *APPLYHOOK*).  (This is mostly to support the debug
X>facilities.)  It is a simple list of sym-val pairs,
X>treated as a stack.
X
Xxldenv tracks the dynamic binding (as opposed to lexical binding). A "flaw"
Xin xlisp is that there is no mechanism for declaring special variables
X(which would be always dynamically bound). You can dynamically bind
Xvariables with PROGV. If my memory serves, only PROGV, EVALHOOK and
X(as I implemented it) APPLYHOOK dynamically bind variables.  For instance,
Xconsider the following variation of the LET example above:
X
X(defun x () x)
X(setq x 10)
X(progv '(x) '(3) (print x) (print (x)))
X
Xwill print 3 and 3. (When execution falls out of progv, the global x is
Xrebound to 10).
X
X
XThis is the best way to override global variable settings in an application,
Xsince the variables will be restored automatically on termination.
X
X
X>Obviously, several of the above types won't fit in a fixed-size
X>two-slot node.  The escape is to have them malloc() some memory
X>and have one of the slots point to it -- VECTOR is the archetype.  For
X>example, see xldmem.c:newvector().  To some extent, this malloc()
X>hack simply exports the memory- fragmentation problem to the C
X>malloc()/free() routines.  However, it helps keep xlisp simple, and it
X>has the happy side-effect of unpinning the body of the vector, so that
X>vectors can easily be expanded and contracted.
X
XXSCHEME which relies more heavily on arrays, maintains a pool of storage
Xto allocate arrays and strings, for which it does garbage collection
Xand (I believe) compaction as well. At any rate, my modified xlisp can
Xoptionally use the xcheme approach which has decided advantages in
Xprograms that use many arrays and strings since the memory does not
Xget fragmented. Enough said.
X
X
X>Xlisp pre-allocates nodes for all ascii characters, and for small
X>integers.  These nodes are never garbage-collected.
X
XThis also speeds up READ, and vastly reduces the number of nodes since
Xall identical characters and small integers are unique. The range of
Xsmall integers treated in this way is compilation settable.
X
X
X>As a practical matter, allocating all nodes in a single array is not
X>very sensible.  Instead, nodes are allocated as needed, in segments of
X>one or two thousand nodes, and the segments linked by a pointer chain
X>rooted at xldmem.c:segs.
X
XThe size of the segment is settable using the ALLOC function.
X
X>You create a symbol in xlisp by using the
X>single-quote operator: "'name", or by calling "(gensym)", or
X>indirectly in various ways.
X
XI would say that 'name is an indirect way to create a symbol. The direct
Xways are using MAKE-SYMBOL (for uninterned symbols) or INTERN (for interned
Xsymbols), or as you mentioned GENSYM (also uninterned). You can make READ
Xcreate an uninterned symbol by preceeding it with #:, otherwise all symbols
Xread by READ are interned.
X
XIn addition, when you make a symbol that starts with the colon character,
Xthe symbol is given itself as the value, otherwise the new symbol has no
Xvalue.
X
X
X>OBJECT is the root of the class hierarchy: everything you can send a
X>message to is of type OBJECT.  (Vectors, chars, integers and so forth
X>stand outside the object hierarchy -- you can't send messages to them.
X>I'm not sure why Dave did it this way.)
X
XProbably because the object facility is an extension of lisp. You can
Xcreate classes of these things. There is also efficiency considerations.
XThe only object oriented programming language I know of where everything
Xis an object is Smalltalk, but if you look at the implementation, it does
Xcheat at the low level to speed things up.
X
X> :isnew -- Does nothing
X
XIt does return the object!
X
X
X>FSUBR: A special primitive fn coded in C, which (like IF) wants its
X>arguments unevaluated.
X
XThese are the "special forms"
X
X>We scan the MESSAGES list in the CLASS object of the recipient,
X>looking for a (message-symbol method) pair that matches our message
X>symbol.  If necessary, we scan the MESSAGES lists of the recipients
X>superclasses too.  (xlobj.c:sendmsg().)  Once we find it, we basically
X>do a normal function evaluation. (xlobjl.c:evmethod().)  Two oddities:
X>We need to replace the message-symbol by the recipient on the argument
X>stack to make things look normal, and we need to push an 'object'
X>stack entry on the xlenv environment so we remember which class is
X>handling the message.
X
X
XThe first "oddity" has an important side effect, when :answer was
Xused to build the method closure, an additional argument, "self", was
Xadded so that the method could access itself with the symbol self.
XThis argument stack fix supplies the needed argument.
X
XThe reason for the second "oddity" is that the method's class is
Xneeded for SEND-SUPER. When one uses SEND-SUPER, the message lookup
Xbegins in the superclass of the method rather than the class of the
Xobject (as with SEND).
X
X>    xlstkcheck(3);    /* Make sure following xlsave */
X>                      /* calls won't overrun stack. */
X>    xlsave(list_ptr); /* Use xlsave1() if you don't */
X>    xlsave(float_ptr);/* do an xlstkcheck().        */
X>    xlsave(int_ptr);
X
Xxlsave also set the variable to nil. If you don't need to do that you
Xcan use xlprot instead of xlsave, or xlprot1 instead of xlsave1
X
X>xlapply, xlevform and sendmsg will issue an error if they encounter a
X>s_macro CLOSURE.  This is presumably because all macros are expanded
X>by xleval.c:xlclose when it builds a closure.
X
XYou are not allowed to use APPLY or FUNCALL with macros in Common
XLisp. There is no way provided to declare macro methods, nor do they
Xmake much sense (at least in my mind).
X
X>Neither xlapply nor sendmsg will handle FSUBRs.  This is presumably
X>a minor bug, left due to the difficulty of keeping arguments
X>unevaluated to that point. ?
X
XYou are not allowed to use APPLY or FUNCALL with special forms. There is
Xno way to declare methods using SUBRs or FSUBRs (the existing SUBR
Xmethods are initialized at load time).
X
XCorrected reply:
XCommon Lisp does not allow APPLYing a macro or special form (FSUBR).
XThis is based on the evaluation model.
XSince SEND is a subr, all of its arguments are already evaluated so it
Xis already too late to have macro or fsubr methods.
X
X>
X> Minor Mysteries:
X> ----------------
X
X>Why doesn't xlevform trace FSUBRs?  Is this a speed hack?
XGood question. Probably not a speed hack. You can't trace macros either.
X
X>Why do both xlobj.c:xloinit() and xlobj.c:obsymvols() initialize the
X>"object" and "class" variables?
X
Xxloinit creates the classes class and object, as well as the symbols, but
Xsets the C variables class and object to point to the class and object.
X
Xobsymbols just set the C variables by looking up the symbols. It is needed
Xbecause when you restore a workspace you don't create new objects but still
Xneed to know where the existing objects are (they might be in a different
Xlocation in the saved workspace). Notice that obsymbols is called by xlsymbols
Xwhich is called both when initializing a new workspace or restoring an old
Xworkspace.
X
X
XTom Almy
[e-mail]
XStandard Disclaimers Apply
X
X-------------------------------------------
X
X
X
X----------------------------cut here---------------------------
X90Nov16 [e-mail] (Jeff Prothero).  Public Domain.
X
X                   +---------------------+
X                   | xlisp 2.1 internals |
X                   +---------------------+
X
X            "Trust the Source, Luke, trust the Source!"
X
X
X Who should read this?
X ---------------------
X
XAnyone poking through the C implementation of xlisp for the first
Xtime.  This is intended to provide a rough roadmap of the global xlisp
Xstructures and algorithms.  If you just want to write lisp code in
Xxlisp, you don't need to read this file -- go read xlisp.doc,
XXlispOOP.doc, and XlispRef.doc, in about that order.  If you want to
Xtinker with the xlisp implementation code, you should *still* read
Xthose three before reading this.  The following isn't intended to be
Xexhaustively precise -- that's what the source code is for!  It is
Xintended only to allow you a fighting change of understanding the code
Xthe first time through (instead of the third time).
X
XAt the bottom of the file you'll find an example of how to add new
Xprimitive functions to xlisp.
X
X
X
X What is an LVAL?
X ----------------
X
XAn "LVAL" is the C type for a generic pointer to an xlisp
Xgarbage-collectable something.  (Cons cell, object, string, closure,
Xsymbol, vector, whatever.)  Virtually every variable in the
Xinterpreter is an LVAL.  Cons cells contain two LVAL slots,
Xsymbols contains four LVAL slots, etc.
X
X
X
X What is the obarray?
X -------------------
X
XThe obarray is the xlisp symbol table.  More precisely, it is a
Xhashtable mapping ascii strings (SYMBOL names) to SYMBOLs.  (The name
X"obarray" is traditional but a bit of a misnomer, since it contains
Xonly xlisp SYMBOLs, and in particular contains no xlisp OBJECTs.)  It
Xis used when converting lisp expressions from text to internal form.
XSince it is a root for the garbage collector, it also serves to
Xdistinguish permanent global-variable SYMBOLs from other SYMBOLs --
Xyou can permanently protect a SYMBOL from the garbage collector by
Xentering it into the obarray.  This is called "interning" the SYMBOL.
XThe obarray is called "obarray" in C and "*OBARRAY*" in xlisp. It is
Xphysically implemented as a VECTOR-valued SYMBOL.
X
X
X
X The Interpreter Stacks
X ----------------------
X
Xxlisp uses two stacks, an "evaluation stack" and an "argument stack".
XBoth are roots for the garbage collector.  The evaluation stack is
Xlargely private to the interpreter and protects internal values from
Xgarbage collection, while the argument stack holds the conventional
Xuser-visible stackframes.
X
X
XThe evaluation stack is an EDEPTH-long array of "LVAL" allocated by
Xxldmem.c:xlminit().  It grows zeroward.
X
Xxlstkbase points to the zero-near end of the evaluation stack.
X
Xxlstktop points to the zero-far end of the evaluation stack; the
Xoccupied part of the stack lies between xlstack and xlstktop.  NOTE
Xthat xlstktop is *NOT* the top of the stack in the conventional sense
Xof indicating the most recent entry on the stack: xlstktop is a static
Xbounds pointer which never changes once the stack is allocated.
X
Xxlstack starts at the zero-far end of the evaluation stack.  *xlstack
Xis the most recent LVAL on the stack.  The garbage collector MARKs
Xeverything reachable from the evaluation stack (among other things),
Xso we frequently push things on this stack while C code is
Xmanipulating them. (Via xlsave(), xlprotect(), xlsave1(), xlprot1().)
X
X
XThe argument stack is an ADEPTH-long array of "LVAL".  It also grows
Xzeroward.  The evaluator pushes arguments on the argument stack at the
Xstart of a function call (form evaluation).  Built-in functions
Xusually eat them directly off the stack.  For user-lisp functions
Xxleval.c:evfun() pops them off the stack and binds them to the
Xappropriate symbols before beginning execution of the function body
Xproper.
X
Xxlargstkbase is the zero-near end of argument stack.
X
Xxlargstktop is the zero-far end of argument stack.  Like xlstktop,
Xxlargstktop is a static bounds pointer which never changes after
Xthe stack is allocated.
X
X*xlsp ("sp"=="stack pointer") is the most recent item on the argument stack.
X
Xxlfp ("fp"=="frame pointer") is the base of the current stackframe.
X
X
X
X  What is a context?
X  ------------------
X
XAn xlisp "context" is something like a checkpoint, recording a
Xparticular point buried in the execution history so that we can
Xabort/return back to it.  Contexts are used to implement call/return,
Xcatch/throw, signals, gotos, and breaks.  xlcontext points to the
Xchain of active contexts, the top one being the second-newest active
Xcontext.  (The newest -- that is, current -- active context is
Ximplemented by the variables xlstack xlenv xlfenv xldenv xlcontext
Xxlargv xlargc xlfp xlsp.)  Context records are written by
Xxljump.c:xlbegin() and read by xljump.c:xljump().  Context records are
XC structures on the C program stack; They are not in the dynamic
Xmemory pool or on the lisp execution or argument stacks.
X
X
X
X  What is an environment?
X  -----------------------
X
XAn environment is basically a store of symbol-value pairs, used to
Xresolve variable references by the lisp program.  xlisp maintains
Xthree environments, in the global variables xlenv, xlfenv and xldenv.
X
Xxlenv and xlfenf are conceptually a single environment, although they
Xare implemented separately.  They are linked-list stacks which are
Xpushed when we enter a function and popped when we exit it.  We also
Xswitch xlenv+xlfenf environments entirely when we begin executing a
Xnew closure (user-fn written in lisp).
X
XThe xlenv environment is the most heavily used environment.  It is
Xused to resolve everyday data references to local variables.  It
Xconsists of a list of frames (and objects).  Each frame is a list of
Xsym-val pairs.  In the case of an object, we check all the instance
Xand class variables of the object, then do the same for its
Xsuperclass, until we run out of superclasses.
X
XThe xlfenv environment is maintained strictly parallel to xlenv, but
Xis used to find function values instead of variable values.  The
Xseparation may be partly for lookup speed and partly for historical
Xreasons.
X
XWhen we send a message, we set xlenv to the value it had when the
Xmessage CLOSURE was built, then push on (obj msg-class), where
Xmsg-class is the [super]class defining the method.  (We also set
Xxlfenv to the value xlfenv had when the method was built.)  This makes
Xthe object instance variables part of the environment, and saves the
Xinformation needed to correctly resolve references to class variables,
Xand to implement SEND-SUPER.
X
XThe xldenv environment tracks the old values of global variables which
Xwe have changed but intend to restore later to their original values,
Xparticularly when we bind and unbind s_evalhook and s_applyhook
X(*EVALHOOK* and *APPLYHOOK*).  (This is mostly to support the debug
Xfacilities.)  It is a simple list of sym-val pairs,
Xtreated as a stack.
X
XThese environments are manipulated in C via the xlisp.h macros
Xxlframe(e), xlbind(s,v), xlfbind(s,v), xlpbind(s,v,e), xldbind(s,v),
Xxlunbind(e).
X
X
X
X  How are xlisp entities stored and identified?
X  ---------------------------------------------
X
XConceptually, xlisp manages memory as a single array of fixed-size
Xobjects.  Keeping all objects the same size simplifies memory
Xmanagement enormously, since any object can be allocated anywhere, and
Xcomplex compacting schemes aren't needed.  Every LVAL pointer points
Xsomewhere in this array.  Every xlisp object has the basic format
X(xldmem.h:typdef struct node)
X
X struct node {
X     char n_type;
X     char n_flags;
X     LVAL car;
X     LVAL cdr;
X }
X
Xwhere n_type is one of:
X
X FREE     A node on the freelist.
X SUBR     A function implemented in C. (Needs evaluated arguments.)
X FSUBR    A special function implemented in C. (Needs unevaluated arguments).
X CONS     A regular lisp cons cell.
X SYMBOL   A symbol.
X FIXNUM   An integer.
X FLONUM   A floating-point number.
X STRING   A string.
X OBJECT   Any object, including class objects.
X STREAM   An input or output file.
X VECTOR      A variable-size array of LVALs.
X CLOSURE  Result of DEFUN or LAMBDA -- a function written in lisp.
X CHAR      An ascii character.
X USTREAM  An internal stream.
X STRUCT      A structure.
X
XMessages may be sent only to nodes with n_type == OBJECT.
X
XObviously, several of the above types won't fit in a fixed-size
Xtwo-slot node.  The escape is to have them malloc() some memory
Xand have one of the slots point to it -- VECTOR is the archetype.  For
Xexample, see xldmem.c:newvector().  To some extent, this malloc()
Xhack simply exports the memory- fragmentation problem to the C
Xmalloc()/free() routines.  However, it helps keep xlisp simple, and it
Xhas the happy side-effect of unpinning the body of the vector, so that
Xvectors can easily be expanded and contracted.
X
XThe garbage collector has special-case code for each of the above node
Xtypes, so it can find all LVAL slots and recycle any malloc()ed ram
Xwhen a node is garbage-collected.
X
XXlisp pre-allocates nodes for all ascii characters, and for small
Xintegers.  These nodes are never garbage-collected.
X
XAs a practical matter, allocating all nodes in a single array is not
Xvery sensible.  Instead, nodes are allocated as needed, in segments of
Xone or two thousand nodes, and the segments linked by a pointer chain
Xrooted at xldmem.c:segs.
X
X
X
X  How are vectors implemented?
X  ----------------------------
X
XAn xlisp vector is a generic array of LVAL slots.  Vectors are also
Xthe canonical illustration of xlisp's escape mechanism for node types
Xwhich need more than two LVAL slots (the maximum possible in the
Xfixed-size nodes in the dynamic memory pool).  The node CAR/CDR slots
Xfor a vector hold a size field plus a pointer to a malloc()ed ram
Xchunk, which is automatically free()ed when the vector is
Xgarbage-collected.
X
Xxldmem.h defines macros for reading and writing vector fields and
Xslots: getsize(), getelement() and setelement().  It also defines
Xmacros for accessing each of the other types of xlisp nodes.
X
X
X
X  How are strings implemented?
X  ----------------------------
X
XStrings work much like vectors: The node has a pointer to a malloc()ed
Xram chunk which is automatically free()ed when the string gets
Xgarbage-collected.
X
X
X
X How are symbols implemented?
X ----------------------------
X
XA symbol is a generic user-visible lisp variable, with separate slots
Xfor print name, value, function, and property list.  Any or all of
Xthese slots (including name) may be NIL.  You create a symbol in C by
Xcalling "xlmakesym(name)" or "xlenter(name)" (to make a symbol and
Xenter it in the obarray). You create a symbol in xlisp by using the
Xsingle-quote operator: "'name", or by calling "(gensym)", or
Xindirectly in various ways.  Most of the symbol-specific code in the
Xinterpreter is in xlsym.c.
X
XPhysically, a symbol is implemented like a four-slot vector.
X
XRandom musing: Abstractly, the LISP symbols plus cons cells (etc)
Xconstitute a single directed graph, and the symbols mark spots where
Xnormal recursive evaluation should stop.  Normal lisp programming
Xpractice is to have a symbol in every cycle in the graph, so that
Xrecursive traversal can be done without MARK bits.
X
X
X
X  How are closures implemented?
X  -----------------------------
X
XA closure, the return value from a lambda, is a regular coded-in-lisp
Xfn.  Physically, it is implemented like an eleven-slot vector, with the
Xnode n_type field hacked to contain CLOSURE instead of VECTOR. The
Xvector slots contain:
X
X name   symbol -- 1st arg of DEFUN.  NIL for LAMBDA closures.
X type   (s_lambda or s_macro). Must be s_lambda to be executable.
X args   List of "required" formal arguments (as symbols)
X oargs  List of "optional" args, each like: (name (default specified-p))
X rest   Name of "&rest" formal arg, else NIL.
X kargs  keyword args, each like: ((':foo 'bar default specified-p))
X aargs  &aux vars, each like: (('arg default))
X body   actual code (as lisp list) for fn.
X env    value of xlenv when the closure was built.  NIL for macros.
X fenv   value of xlfend when the closure was built. NIL for macros.
X lambda The original formal args list in the DEFUN or LAMBDA.
X
XThe lambda field is for printout purposes.  The remaining fields store
Xa predigested version of the formal args list.  This is a limited form
Xof compilation: by processing the args list at closure-creation time,
Xwe reduce the work needed during calls to the closure.
X
X
X
X  How are objects implemented?
X  ----------------------------
X
XAn object is implemented like a vector, with the size determined by
Xthe number of instance variables.  The first slot in the vector points
Xto the class of the object; the remaining slots hold the instance
Xvariables for the object.  An object needs enough slots to hold all
Xthe instance variables defined by its class, *plus* all the instance
Xvariables defined by all of its superclasses.
X
X
X
X  How are classes implemented?
X  ----------------------------
X
XA class is a specific kind of object, hence has a class pointer plus
Xinstance variables.  All classes have the following instance variables:
X
X MESSAGES   A list of (interned-symbol method-closure) pairs.
X IVARS        Instance variable names: A list of interned symbols.
X CVARS      Class variable names:    A list of interned symbols.
X CVALS      Class variable values:   A vector of values.
X SUPERCLASS A pointer to the superclass.
X IVARCNT    Number of class instance variables, as a fixnum.
X IVARTOTAL  Total number of instance variables, as a fixnum.
X
XIVARCNT is the count of the number of instance variables defined by
Xour class.  IVARTOTAL is the total number of instance variables in an
Xobject of this class -- IVARCNT for this class plus the IVARCNTs from
Xall of our superclasses.
X
X
X
X
X  How is the class hierarchy laid out?
X  ------------------------------------
X
XThe fundamental objects are the OBJECT and CLASS class objects.  (Both
Xare instances of class CLASS, and since CLASSes are a particular kind
Xof OBJECT, both are also objects, with n_type==OBJECT.  Bear with me!)
X
XOBJECT is the root of the class hierarchy: everything you can send a
Xmessage to has OBJECT as its class or super*class.  (Vectors, chars,
Xintegers and so forth stand outside the object hierarchy -- you can't
Xsend messages to them.  I'm not sure why Dave did it this way.) OBJECT
Xdefines the messages:
X
X :isnew -- Does nothing
X :class -- Returns contents of class-pointer slot.
X :show  -- Prints names of obj, obj->class and instance vars.
X
XSince a CLASS is a specialized type of OBJECT (with instance variables
Xlike MESSAGES which generic OBJECTs lack), class CLASS has class
XOBJECT as its superclass.  The CLASS object defines the messages:
X
X :new     -- Create new object with self.IVARTOTAL LVAR slots, plus
X            one for the class pointer. Point class slot to self.
X            Set new.n_type char to OBJECT.
X :isnew     -- Fill in IVARS, CVARS, CVALS, SUPERCLASS, IVARCNT and
X            IVARTOTAL, using parameters from :new call.  (The
X            :isnew msg inherits the :new msg parameters because
X            the  :isnew msg is generated automatically after
X            each :new   msg, courtesy of a special hack in
X            xlobj.c:sendmsg().)
X :answer -- Add a (msg closure) pair to self.MESSAGES.
X
X
X
XHere's a figure to summarize the above, with a generic object thrown
Xin for good measure.  Note that all instances of CLASS will have a
XSUPERCLASS pointer, but no normal object will.  Note also that the
Xmessages known to an object are those which can be reached by
Xfollowing exactly one Class Ptr and then zero or more Superclass Ptrs.
XFor example, the generic object can respond to :ISNEW, :CLASS and
X:SHOW, but not to :NEW or :ANSWER.  (The functions implementing the
Xgiven messages are shown in parentheses.)
X
X                    NIL
X                     ^
X                     |
X                     |Superclass Ptr
X                     |
X                Msg+--------+
X :isnew (xlobj.c:obisnew) <----|  class |Class Ptr
X :class (xlobj.c:obclass) <----| OBJECT |------------+
X :show    (xlobj.c:objshow) <----|        |            |
X                   +--------+            |
X       +---------+                ^  ^               |
X       | generic |Class Ptr       |  |               |
X       | object  |----------------+  |Superclass Ptr |
X       +---------+             |               |
X                Msg+--------+            |
X :isnew    (xlobj.c:clnew)      <----| class  |Class Ptr   |
X :new    (xlobj.c:clisnew) <----| CLASS  |--------+   |
X :answer(xlobj.c:clanswer)<----|        |        |   |
X                   +--------+        |   |
X                  ^  ^           |   |
X                  |  |           |   |
X                  |  +-----------+   |
X                  +------------------+
X
X
XThus, class CLASS inherits the :CLASS and :SHOW messages from class
XOBJECT, overrides the default :ISNEW message, and provides new
Xmessages :NEW and :ANSWER.
X
XNew classes are created by (send CLASS :NEW ...) messages.  Their
XClass Ptr will point to CLASS.  By default, they will have OBJECT as
Xtheir superclass, but this can be overridden by the second optional
Xargument to :NEW.
X
XThe above basic structure is set up by xlobj.c:xloinit().
X
X
X
X  How do we look up the value of a variable?
X  ------------------------------------------
X
XWhen we're cruising along evaluating an expression and encounter a
Xsymbol, the symbol might refer to a global variable, an instance
Xvariable, or a class variable in any of our superclasses.  Figuring
Xout which means digging through the environment.  The canonical place
Xthis happens is in xleval.c:xleval(), which simply passes the buck to
Xxlsym.c:xlgetvalue(), which in turn passes the buck to
Xxlxsym.c:xlxgetvalue(), where the fun of scanning down xlenv begins.
XThe xlenv environment looks something like
X
X     Backbone    Environment frame contents
X     --------    --------------------------
Xxlenv --> frame      ((sym val) (sym val) (sym val) ... )
X      frame      ...
X      object     (obj msg-class)
X      frame      ...
X      object     ...
X      frame      ...
X      ...
X
XThe "frame" lines are due to everyday nested constructs like LET
Xexpressions, while the "object" lines represent an object environment
Xentered via a message send.  xlxgetvalue scans the enviroment left to
Xright, and then top to bottom.  It scans down the regular environment
Xframes itself, and calls xlobj.c:xlobjgetvalue() to search the object
Xenvironment frames.
X
Xxlobjgetvalue() first searches for the symbol in the msg-class, then
Xin all the successive superclasses of msg-class.  In each class, it
Xfirst checks the list of instance-variable names in the IVARS slot,
Xthen the list of class-variables name in the CVARS slot.
X
X
X
X  How are function calls implemented?
X  -----------------------------------
X
Xxleval.c contains the central expression-evaluation code.
Xxleval.c:xleval() is the standard top-level entrypoint.  The two
Xcentral functions are xleval.c:xlevform() and xleval.c:evfun().
Xxlevform() can evaluate four kinds of expression nodes:
X
XSUBR: A normal primitive fn coded in C.  We call evpushargs() to
Xevaluate and push the arguments, then call the primitive.
X
XFSUBR: A special primitive fn coded in C, which (like IF) wants its
Xarguments unevaluated.  We call pushargs() (instead of evpushargs())
Xand then the C fn.
X
XCLOSURE: A preprocessed written-in-lisp fn from a DEFUN or LAMBDA.  We
Xcall evpushargs() and then evfun().
X
XCONS: We issue an error if CONS.car isn't a LAMBDA, otherwise we call
Xxleval.c:xlclose() to build a CLOSURE from the LAMBDA, and fall into
Xthe CLOSURE code.
X
XThe common thread in all the above cases is that we call evpushargs()
Xor pushargs() to push all the arguments on the evaluation stack,
Xleaving the number and location of the arguments in the global
Xvariables xlargc and xlargv.  The primitive C functions consume
Xtheir arguments directly from the argument stack.
X
Xxleval.c:evfun() evaluates a CLOSURE by:
X
X(1) Switching xlenv and xlfenv to the values they had when
Xthe CLOSURE was built. (These values are recorded in the CLOSURE.)
X
X(2) Binding the arguments to the environment.  This involves scanning
Xthrough the section of the argument stack indicated by xlargc/xlargv,
Xusing information from the CLOSURE to resolve keyword arguments
Xcorrectly and assign appropriate default values to optional arguments,
Xamong other things.
X
X(3) Evaluating the body of the function via xleval.c:xleval().
X
X(4) Cleaning up and restoring the original environment.
X
X
X
X  How are message-sends implemented?
X  ----------------------------------
X
XWe scan the MESSAGES list in the CLASS object of the recipient,
Xlooking for a (message-symbol method) pair that matches our message
Xsymbol.  If necessary, we scan the MESSAGES lists of the recipient's
Xsuperclasses too.  (xlobj.c:sendmsg().)  Once we find it, we basically
Xdo a normal function evaluation. (xlobjl.c:evmethod().)  Two oddities:
XWe need to replace the message-symbol by the recipient on the argument
Xstack to make things look normal, and we need to push an 'object'
Xstack entry on the xlenv environment so we remember which class is
Xhandling the message.
X
X
X
X  How is garbage collection implemented?
X  --------------------------------------
X
XThe dynamic memory pool managed by xlisp consists of a chain of memory
Xsegments (xldmem.h:struct segment) rooted at global C variable "segs".
XEach segment contains an array of "struct node"s plus a pointer to the
Xnext segment.  Each node contains a n_type field and a MARK bit, which
Xis zero except during garbage collection.
X
XXlisp uses a simple, classical mark-and-sweep garbage collector.  When
Xit runs out of memory (fnodes==NIL), it does a recursive traversal
Xsetting the MARK flag on all nodes reachable from the obarray, the
Xthree environments xlenv/xlfenv/xldenv, and the evaluation and
Xargument stacks.  (A "switch" on the n_type field tells us how to find
Xall the LVAL slots in the node (plus associated storage), and a
Xpointer-reversal trick lets us avoid using too much stack space during
Xthe traversal.)  sweep() then adds all un-MARKed LVALs to fnodes, and
Xclears the MARK bit on the remaining nodes.  If this fails to produce
Xenough free nodes, a new segment is malloc()ed.
X
XThe code to do this stuff is mostly in xldmem.c.
X
X
X
X How do I add a new primitive fn to xlisp?
X -----------------------------------------
X
XAdd a line to the end of xlftab.c:funtab[].  This table contains a
Xlist of triples:
X
XThe first element of each triple is the function name as it will
Xappear to the programmer. Make it all upper case.
X
XThe second element is S (for SUBR) if (like most fns) your function
Xwants its arguments pre-evaluated, else F (for FSUBR).
X
XThe third element is the name of the C function to call.
X
XRemember that your arguments arrive on the xlisp argument stack rather
Xthan via the usual C parameter mechanism.
X
XCAUTION: Try to keep your files separate from generic xlisp files, and
Xto minimize the number of changes you make in the generic xlisp files.
XThis way, you'll have an easier time re-installing your changes when
Xnew versions of xlisp come out.  For example, if you are going to add
Xmany primitive functions to your xlisp, use an #include file rather
Xthan putting them all in xlftab.c.  It's a good idea to put a marker
X(like a comment with your initials) on each line you change or insert
Xin the generic xlisp fileset.
X
XCAUTION: Remember that you usually need to protect the LVAL variables
Xin your function from the garbage-collector.  It never hurts to do
Xthis, and often produces obscure bugs if you do not.  You protect
Xuninitialized local variables with xlsave1() and initialized local
Xvariables with xlprot1().
X
XBE CAREFUL NOT TO PROTECT UNINITIALIZED LOCAL VARIABLES WITH XLPROT1()
XOR XLPROTECT()!  This will appear to work fine until garbage
Xcollection happens at an inconvenient moment, at which point the
Xgarbage collector will wind up following your uninitialized pointer
Xoff to never-never land.
X
XNote: If you have several pointers to protect, you can save a little
Xruntime and codespace by using
Xxlstkcheck(number-of-variables-to-protect) followed by xlsave()s and
Xxlprotect()s instead of the more expensive xlsave1()s and xlprot1()s.
X
XGeneric code for a new primitive fn:
X
X/* xlsamplefun - do useless stuff.        */
X/* Called like (samplefun '(a c b) 1 2.0) */
XLVAL xlsamplefun()
X{
X    /* Variables to hold the arguments: */
X    LVAL    list_arg, integer_arg, float_arg;
X
X    /* Get the arguments, with appropriate errors */
X    /* if any are of the wrong type.  Look in     */
X    /* xlisp.h for macros to read other types of  */
X    /* arguments.  Look in xlmath.c for examples  */
X    /* of functions which can handle an argument  */
X    /* which may be either int or float:          */
X    list_arg    = xlgalist()  ;  /* "XLisp Get A LIST"   */
X    integer_arg = xlgafixnum();  /* "XLisp Get A FIXNUM" */
X    float_arg   = xlgaflonum();  /* "XLisp Get A FLONUM" */
X
X    /* Issue an error message if there are any extra arguments: */
X    xllastarg();
X
X
X
X    /* Call a separate C function to do the actual  */
X    /* work.  This way, the main function can       */
X    /* be called from both xlisp code and C code.   */
X    /* By convention, the name of the xlisp wrapper */
X    /* starts with "xl", and the native C function  */
X    /* has the same name minus the "xl" prefix:     */
X    return samplefun( list_arg, integer_arg, float_arg );
X}
XLVAL samplefun( list_arg, integer_arg, float_arg )
XLVAL            list_arg, integer_arg, float_arg;
X{
X    FIXTYPE val_of_integer_arg;
X    FLOTYPE val_of_float_arg;
X
X    /* Variables which will point to LISP objects: */
X    LVAL result;
X    LVAL list_ptr;
X    LVAL float_ptr;
X    LVAL int_ptr;
X
X    /* Protect our internal pointers by */
X    /* pushing them on the evaluation   */
X    /* stack so the garbage collector   */
X    /* can't recycle them in the middle */
X    /* of the routine:                  */
X    xlstkcheck(4);    /* Make sure following xlsave */
X                      /* calls won't overrun stack. */
X    xlsave(list_ptr); /* Use xlsave1() if you don't */
X    xlsave(float_ptr);/* do an xlstkcheck().        */
X    xlsave(int_ptr);
X    xlsave(result);
X
X    /* Semantic check, illustrating use of xlfail(): */
X    if (list_ptr == NULL) {
X        xlfail("null list");
X        /* Won't return. */
X    }
X
X    /* Create an internal list structure, protected */
X    /* against garbage collection until we exit fn: */
X    list_ptr = cons(list_arg,list_arg);
X
X    /* Get the actual values of our fixnum and flonum: */
X    val_of_integer_arg = getfixnum( integer_arg );
X    val_of_float_arg   = getflonum( float_arg   );
X
X    /* Semantic check, illustrating use of xlerror(): */
X    if (val_of_integer_arg < -2) {
X        xlerror("bad integer",cvfixnum(val_of_integer_arg));
X        /* Won't return. */
X    }
X
X
X
X    /*******************************************/
X    /* You can have any amount of intermediate */
X    /* computations at this point in the fn... */
X    /*******************************************/
X
X
X    /* Make new numeric values to return: */
X    integer_ptr = cvfixnum( val_of_integer_arg * 3   );
X    float_ptr   = cvflonum( val_of_float_arg   * 3.0 );
X
X    /* Cons it all together to produce a return value: */
X    result = cons( float_ptr,   NIL    );
X    result = cons( integer_ptr, result );
X    result = cons( list_ptr,    result );
X
X    /* Restore the stack, canceling the xlsave()s: */
X    xlpopn(4); /* Use xlpop() for a single argument.*/
X
X    return result;
X}
X
X
X
X Example of what NOT to do:
X --------------------------
X
XHere's a function I wrote which does *NOT* correctly prevent the
Xgarbage collector from stealing its dynamically allocated cells:
X
XLVAL incorrect_Point_To_List( p )/*DON'T USE THIS CODE! */
Xgeo_point*              p;
X/*-
X    Convert point to (x y z) list.
X-*/
X{
X    LVAL result;
X    xlsave1(result);
X    result = cons(              /* THIS CODE IS BROKEN! */
X        cvflonum(     p->x), /* THIS CODE IS BROKEN! */
X        cons(            /* THIS CODE IS BROKEN! */
X            cvflonum(    p->y), /* THIS CODE IS BROKEN! */
X            cons(        /* THIS CODE IS BROKEN! */
X                cvflonum(p->z),    /* THIS CODE IS BROKEN! */
X                NIL        /* THIS CODE IS BROKEN! */
X            )            /* THIS CODE IS BROKEN! */
X        )            /* THIS CODE IS BROKEN! */
X    );                /* THIS CODE IS BROKEN! */
X    xlpop();
X    return result;
X}
X
XThe problem with the above function is that the "z" cell will be
Xallocated first, and is not protected during the allocation of the "y"
Xflonum (or vice versa, depending on the order the compiler chooses to
Xevaluate these arguments). Similarly, the "y" cell is not protected
Xduring allocation of the "x" flonum. Here is a correct version, in
Xwhich "result" always protects the list-to-date:
X
XLVAL correct_Point_To_List( p )
Xgeo_point*            p;
X/*-
X    Convert point to (x y z) list.
X-*/
X{
X    LVAL result;
X    xlsave1(result);
X    result = cons( cvflonum(p->z), NIL        );
X    result = cons( cvflonum(p->y), result    );
X    result = cons( cvflonum(p->x), result    );
X    xlpop();
X    return result;
X}
X
X
X Minor Observations:
X -------------------
X
Xxlapply, xlevform and sendmsg will issue an error if they encounter a
Xs_macro CLOSURE.  This is presumably because all macros are expanded
Xby xleval.c:xlclose when it builds a closure.
X
XNeither xlapply nor sendmsg will handle FSUBRs.  This is presumably
Xa minor bug, left due to the difficulty of keeping arguments
Xunevaluated to that point. ?
X
XSince xlisp tracks the three most recent input expressions (in
Xvariables +, ++ and +++) and three most recent results (in variables
X*, ** and ***), things may occasionally not get garbage-collected as
Xsoon as you expect!
X
X
X
X Minor Mysteries:
X ----------------
X
XWhy doesn't xlevform trace FSUBRs?  Is this a speed hack?
X
XWhy do both xlobj.c:xloinit() and xlobj.c:obsymvols() initialize the
X"object" and "class" variables?
END_OF_FILE
if test 39828 -ne `wc -c <'src/xlisp/xcore/doc/internals.doc'`; then
    echo shar: \"'src/xlisp/xcore/doc/internals.doc'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/doc/internals.doc'
fi
echo shar: End of archive 13 \(of 16\).
cp /dev/null ark13isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 16 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0